perm filename CRESC.F4[P11,LCS] blob sn#579537 filedate 1981-04-15 generic text, type T, neo UTF8
C****** CRESC.F4  ---- HEAVY, HBRACK, CBRACK, RPDOT -----
      SUBROUTINE CRESC
C DRAWS CRESC. AND RECTANGLES *****
      IMPLICIT INTEGER(A-Q,S-Z)
      REAL OLDY,STFF,XDIS
      COMMON /STF/RSTFAC(0/7),RSTJ2 /MIN/MINI,RMINI
      COMMON R2,JA,CENTR,J2,RJQ(20),JQ(16) /BM/RA,RC,RJY
      COMMON /POSI/STFF(0/7),JJ2,POS /PLTR/PLT,RHT,DIS,XDIS
      COMMON /ALF/QQ(3),RST7,RST18,R3Q,JY,RD,RX,RW,RJX,RJ,L,K,
     1 RJA,YY,DISX,HGT,RZ,INP(53) /OLDTOP/OLDY
      EQUIVALENCE (R11,RJQ(9)),(R6,RJQ(4)),(J8,JQ(6)),(J10,JQ(8))
     1,(R9,RJQ(7)),(R8,RJQ(6)),(R3,RJQ(1)),(R7,RJQ(5)),(R4,RJQ(2))
300	IF(R7.EQ.0)R7=2.3
      IF(R7.EQ.-1.)R7=-2.3
      RA=ABS(R7/2.0)*RST7
C   AMOUNT OF SPREAD
	RJ=R3Q
      RX=RX-RST18+RD
      IF(R8.NE.0)GO TO 302
C  JUMP TO MAKE BOX
      R6=RHORZ(R6)
      IF(R7.LT.0)GO TO 301
	RJ=R6
	R6=R3Q
301	CALL LINX(RJ,RA+RX,R6,RX)
	CALL LINES(RJ,RX-RA,2)
C FOR CRESC, DECRESC:4 POS1, STF, HGT, 50, POS1, +OR-N(0=2.3,-1=-2.3)
      IF(PLT.GE.0)RETURN
C   THIS MAKES ALL CRESC. DBL THICKNESS AT PRINT TIME.
      IF(J8.LT.0)RETURN
	RX=RX+XDIS
	J8=-1
C FOR DOUBLE THICKNESS
	GO TO 301
302	R8=R8*RST7
      R9=R9*RST7
      IF(R9.EQ.0)R9=R8
C  R9=0 MAKES SQUARE
      R3=R3Q-R8/2.
      RX=RX-R9/2.
      OLDY=RX
      IF(R11.NE.0)OLDY=OLDY+R11*RST7
C  R11 IS OFFSET FOR PARALLELAGRAM
C DRAWS BOX, CENTER IS IN MIDDLE
C  4,POSI+=9,STF,NT#,50,0,0,,SIZ1↑BY NT#S↑,SIZ2
1302	CALL LINX(R3,RX,R3+R8,OLDY)
      CALL LINES(R3+R8,OLDY+R9,2)
	CALL LINES(R3,RX+R9,2)
	CALL LINES(R3,RX,2)
	IF(J10.EQ.0)RETURN
	J10=J10-1
	RJ=XDIS
      R3=R3-RJ
      R8=R8+RJ+RJ
      RX=RX-RJ
      OLDY=OLDY-RJ
      R9=R9+RJ+RJ
      GO TO 1302
C TO THICKEN BOXES.
	END

      SUBROUTINE HEAVY
      COMMON R2,JA,CENTR,J2,RJQ(20),JQ(16) /BM/RA,RC,RJY
      COMMON /ALF/QQ(3),RST7,RST18,R3Q,JY,RD,RX,RW,RJX,RJ,L,K,
     1 RJA,YY,DISX,HGT,RZ,INP(53) /OLDTOP/OLDY
      EQUIVALENCE (R6,RJQ(4)),(J10,JQ(8)),(J7,JQ(5))
C  FOR 'HEAVY' LINE.
C P10 = NUM. OF ADDITIONAL LINES.
C ****** ONLY GOOD FOR SLOPE OF LESS THAN 45 DEG.
	J7=J7-1
	J10=J7
C GET SHIFT INCREMENT (DEPENDS ON FINAL SIZE)
	RR=ABS(RX-OLDY)
C RR HAS AMOUNT OF Y SHIFT IN LINE
	RQ=ABS(R3Q-RJX)
C  RQ HAS AMOUNT OF X SHIFT IN LINE
	RQ=RQ-RR
	IF(RQ.GE.0)GO TO 1402
C MOVE RIGHT ONE SCAN LINE FOR NEXT VECTOR
	R3Q=R3Q+RA
	RJX=RJX+RA
C R3Q AND RJX ARE THE 2 X COORDS.
	RETURN
1402	RX=RX+RA
C MOVE UP ONE SCAN LINE FOR NEXT VECTOR
	OLDY=OLDY+RA
C RX AND OLDY ARE THE 2 Y COORDS.
C GO DRAW IT
	END

      SUBROUTINE HBRACK
      COMMON/STF/RSTFAC(0/7),RSTJ2
      COMMON R2,JA,CENTR,J2,RJQ(20),JQ(16),RE,RF,DBR,RH/BM/RA,RC,RJY
      COMMON/POSI/STFF(0/7),JJ2,POS/PLTR/PLT,RHT,DIS,XDIS
      COMMON/ALF/QQ(3),RST7,RST18,R3Q,JY,RD,RX,RW,RJX,RJ,L,K,
     1 RJA,YY,DISX,HGT,RZ,INP(53) /OLDTOP/OLDY
      EQUIVALENCE (J4,JQ(2)),(R5,RJQ(3)),(R6,RJQ(4)),(R4,RJQ(2))
1401 	R4=2.0
C FOR HEAVY BRACK.
	RA=RST7
	RX=RX-RA
C  THE BOTTOM
	L=J4+J2-1
	R6=3.0
	IF(L.LE.7)GO TO 4401
	L=7
	R6=300.
4401	RA=STFF(L)
C  SAVE FOR POS. OF BRACK. END ON UPPER STAFF.
	RJY=RSTFAC(L)
	OLDY=RA+(R6+63.)*RJY
C  THE TOP
	R5=9.5
	END

      SUBROUTINE CBRACK
      COMMON /STF/RSTFAC(0/7),RSTJ2 
      COMMON R2,JA,CENTR,J2,RJQ(20),JQ(16)
      COMMON /POSI/STFF(0/7),JJ2,POS
      COMMON /ALF/QQ(3),RST7,RST18,R3Q,JY,RD,RX,RW,RJX,RJ,L,K,
     1 RJA,YY,DISX,HGT,RZ,INP(53) /OLDTOP/OLDY
      EQUIVALENCE (J4,JQ(2)),(J5,JQ(3)),(R6,RJQ(4)),(J8,JQ(6))
     1,(R8,RJQ(6)),(R7,RJQ(5)),(R4,RJQ(2))
      J5=5 
C FOR CURVY BRACKET.  P8 CAN CHANGE WIDTH.
      J4=J4+J2-1
	R7=(.3136*RSTFAC(J4)+.0056*(STFF(J4)-STFF(J2)))/RSTJ2
C  .0056=.0392/7.(THE MAGIC NUM FOR VERT SIZE OF BRACK.) .3136=8*.0392
C   ADD DIST BETWEEN BOTTOM OF STAVES TO HEIGHT OF TOP STAFF
C ***** USE P8 FOR WIDTH FACTOR!! *****
	J8=0
      	R6=R8
	 R8=0
      IF(R6.EQ.0)R6=1.+R6/20.
      JA=3
      R4=2.3
C   BECAUSE BRACK DOESN'T REALLY GO UP FROM 0 ?!?X*↑
      CALL CLEFS
      END

      SUBROUTINE RPDOT
C  PUTS IN DOTS ON DOUBLE-BAR REPEATS
      IMPLICIT INTEGER(A-Q,S-Z)
      REAL DIS,DISX,HGT,POS,CENTR,STFF,HGT1,XDIS
      COMMON/STF/RSTFAC(0/7),RSTJ2
      COMMON R2,JA,CENTR,J2,RJQ(20),JQ(16),RE,RF,DBR,RH/BM/RA,RC,RJY
      COMMON/POSI/STFF(0/7),JJ2,POS/PLTR/PLT,RHT,DIS,XDIS
      COMMON/ALF/QQ(3),RST7,RST18,R3Q,JY,RD,RX,RW,RJX,RJ,L,K,
     1 RJA,YY,DISX,HGT,RZ,INP(53)
      COMMON/DAT/RACNT(69),RDOT(17)
      EQUIVALENCE (J3,JQ(1)),(J4,JQ(2)),(J5,JQ(3)),(R4,RJQ(2))
     1,(J7,JQ(5)),(R3,RJQ(1))
       L=J4
C SAVE J4 IN L UNTIL END 
      RJ=L/100
	IF(RJ.EQ.0)RJ=6.*RSTJ2
C  HEAVY BAR WILL BE 5 LINES WIDE.
      RZ=R3
      J4=0
C   MUST BE 0 FOR DOTS IN 'NOTWRT'
	IF(DBR.NE.0)GO TO 2
	IF(J5.GT.3)J5=3
	DBR=J5 
2     J5=0
C  J5=1 RPT ↑, =2 RPT ↑, =3 RPT ↑
      RJA=RD*2.
C TO SPACE DOTS, NOT ACCURATE FOR VERY SMALL OR VERY LARGE SIZE FACTORS
      JY=DBR
      IF(DBR.LT.2)GO TO 8400
      R3=RJA+RJ+RZ
7400  DO 3400 K=J2,MOD(L,100)+J2-1
C PUT DOTS ON ALL STAVES COVERED BY BAR LINE.
4      RSTJ2=RSTFAC(K)
      POS=STFF(K)
      R4=6
      CALL CENTX
C  SPACES DOTS OUT FROM BAR
      CALL RDRAW(1,17.0,RDOT,RSTJ2,R3,CENTR+RSTJ2,RSTJ2)
C /DAT/+=69		;EXTENDED FOR +65 TO +69 1/78
C  GO GET THE DOT
      R4=8
      CALL CENTX
3400  CALL RDRAW(1,17.0,RDOT,RSTJ2,R3,CENTR+RSTJ2,RSTJ2)
      JY=JY-1
	IF(JY.LT.2)GO TO 4400
8400    R3=RZ-RJA-4.*RSTJ2
      GO TO 7400
C  DO I NEED ANY MORE RESETS????
4400  J4=L
      J7=RJ*DIS
	END